home *** CD-ROM | disk | FTP | other *** search
/ START Magazine / START VOL 3 NO 7.st / MOON.ARC / MOON.LST next >
Encoding:
File List  |  1988-11-11  |  5.8 KB  |  237 lines
  1. Rem ******* MOON CALENDAR ***********
  2. Rem
  3. Rem by Jeff Adkins
  4. Rem
  5. Rem Copyright 1988 Antic Publishing
  6. Rem
  7. Rem *********************************
  8. Dim Month(12),Ph(12,31),Phcx(12,31),Phcy(12,31)
  9. Dim Spalette%(16,3)
  10. Res%=Xbios(4)
  11. If Res%=0
  12.   Alert 1,"Moon Calendar requires|medium or high resolution.",1,"Ok",D
  13.   End
  14. Endif
  15. '
  16. Rem now get the blank picture.
  17. '
  18. Moon_child$="MOON.PI"+Str$(Res%+1)
  19. If Not Exist(Moon_child$)
  20.   A$=Moon_child$+" must be in the same|directory as MOON.PRG."
  21.   Alert 1,A$,1,"Abort",D
  22.   End
  23. Endif
  24. '
  25. @Save_pal
  26. @Degas(Moon_child$)
  27. Sget Moon_pic$
  28. Finished!=False
  29. New_moon!=True
  30. Repeat
  31.   '
  32.   If New_moon!
  33.     Gosub Titles ! asks for the current year
  34.     Sput Moon_pic$
  35.     Gosub Pasteyear ! Inserts current year
  36.     Gosub January1 ! Initializes the starting point for the Phase Array
  37.     Gosub Phasearray ! Calculates the phase for each day in the array
  38.     Gosub Outlines ! Draws circles for each phase of the moon.
  39.     Gosub Filler !Fills in the phases.
  40.     New_moon!=False
  41.   Endif
  42.   Repeat
  43.     Mouse Xclick,Yclick,K
  44.   Until K<>0
  45.   '
  46.   Finished!=K=2
  47.   '
  48.   If Xclick>=37 And Yclick>=170*Res% And Xclick<=90 And Yclick<=184*Res%
  49.     Finished!=True
  50.   Endif
  51.   '
  52.   If Xclick>=544 And Yclick>=170*Res% And Xclick<=597 And Yclick<=184*Res%
  53.     Gosub Papercopy ! Produces a hardcopy if requested.
  54.   Endif
  55.   '
  56.   If Xclick>=297 And Yclick>=20*Res And Xclick<=392 And Yclick<=30*Res%
  57.     New_moon!=True
  58.   Endif
  59.   '
  60. Until Finished!
  61. '
  62. @Restorepal
  63. End
  64. Procedure Titles
  65.   Cls
  66.   Print "MOON CALENDAR"
  67.   Print "(V. 2.0)"
  68.   Print "by Jeff Adkins"
  69.   Print
  70.   Askyear:
  71.   Input "Please enter the year (>=1985):";Year
  72.   If Year<1985 Then
  73.     Print "The year must be greater than 1985."
  74.     Goto Askyear
  75.   Endif
  76.   Cls
  77. Return
  78. Procedure January1
  79.   Restore
  80.   For I=1 To 12 ! read in normal year month lengths
  81.     Read Length
  82.     Month(I)=Length
  83.   Next I
  84.   Rem Change February for leap years
  85.   If Year/4=Int(Year/4)
  86.     Month(2)=29
  87.   Endif
  88.   If Year/400=Int(Year/400) !There is not a leap year for 2000 AD
  89.     Month(2)=28
  90.   Endif
  91.   Data 31,28,31,30,31,30,31,31,30,31,30,31
  92.   Rem On December 22, 1984, 12 minutes before midnight
  93.   Rem Universal Time there was a New Moon.  This was
  94.   Rem 203.68 hours before midnight on December 31.
  95.   Time=203.68
  96.   Rem Add hours for each year beyond 1985
  97.   Time=Time+(365.24*23.9344)*(Year-1985)
  98.   Rem Add 20 hours to get to 10 pm
  99.   Rem then subtract 5 hours since benchmark is universal time
  100.   Rem and I am converting to eastern time.
  101.   Rem central time
  102.   Rem  subtract 6 hours
  103.   Rem mountain time
  104.   Rem  subtract 7 hours
  105.   Rem pacific time
  106.   Rem  subtract 8 hours
  107.   Rem daylight savings time
  108.   Rem  add 1 hour
  109.   Time=Time+15
  110. Return
  111. Procedure Phasearray
  112.   For Months=1 To 12
  113.     For Days=1 To Month(Months)
  114.       Cx=18*Days+42
  115.       Cy=(9*Res%)*Months+(50*Res%)
  116.       Rem now record the x and y coordinates in the array Phcx,phcy
  117.       Phcx(Months,Days)=Cx
  118.       Phcy(Months,Days)=Cy
  119.       Rem Now divide by the number of hours in the time it takes the moon phase to repeat
  120.       Phase=Time/(29.530588*23.9344)
  121.       Phase=Phase-Int(Phase)
  122.       Ph(Months,Days)=Phase
  123.       Time=Time+23.9344
  124.     Next Days
  125.   Next Months
  126. Return
  127. Procedure Outlines
  128.   For Months=1 To 12
  129.     For Days=1 To Month(Months)
  130.       Cx=Phcx(Months,Days)
  131.       Cy=Phcy(Months,Days)
  132.       Ellipse Cx,Cy,8.5,(4.25*Res%),0,3600
  133.     Next Days
  134.   Next Months
  135. Return
  136. Procedure Filler
  137.   For Months=1 To 12
  138.     For Days=1 To Month(Months)
  139.       Phase=Ph(Months,Days)
  140.       Cx=Phcx(Months,Days)
  141.       Cy=Phcy(Months,Days)
  142.       If Phase<=0.5
  143.         Theta=Phase*6.283
  144.       Else
  145.         Theta=(Phase-0.5)*6.283
  146.       Endif
  147.       R=7.5
  148.       For Y=-R To R
  149.         Lx=-Sqr(R*R-(Y*Y))
  150.         Rx=Abs(Lx)*Cos(Theta)
  151.         If Phase>0.5
  152.           Swap Rx,Lx
  153.           Rx=-Rx
  154.         Endif
  155.         Line Lx+Cx,(Y/2)*Res%+Cy,Rx+Cx,Cy+(Y/2)*Res%
  156.         '        Line Lx+Cx,Y+Cy,Rx+Cx,Cy+Y
  157.       Next Y
  158.     Next Days
  159.   Next Months
  160. Return
  161. Procedure Dotplot
  162.   Cx=Phcx(M,D)
  163.   Cy=Phcy(M,D)
  164.   Line Cx,Cy,Cx,Cy
  165.   Color 1
  166. Return
  167. Procedure Papercopy
  168.   '
  169.   Alert 2,"Please ready printer|   for hardcopy.",1,"Ok|Cancel",Pressed
  170.   If Pressed=1
  171.     Hidem
  172.     Hardcopy
  173.     Showm
  174.   Endif
  175. Return
  176. Procedure Pasteyear
  177.   Color 0
  178.   Tester:
  179.   Graphmode 2
  180.   Deftext 1,0,0,16*Res%
  181.   Text 510,35*Res%,Year
  182.   Color 1
  183. Return
  184. Procedure Degas(Filename$)
  185.   ' This assumes main program has done necessary error trapping.
  186.   '
  187.   ' This will work for pictures of any resolution, uncompressed format
  188.   '
  189.   ' To hold more than one picture in memory, dimension Colr$ to however many
  190.   ' pictures you want, and hold pallete there and change procedure parameters
  191.   ' to Degas(Filename$,Col) where Col is the subscript.
  192.   '
  193.   Open "I",#2,Filename$ ! Assume it exists
  194.   Temp$=Input$(36,#2) !
  195.   Colr$=Mid$(Temp$,3,36) ! Put pallette in Colr$
  196.   Close #2 ! Close
  197.   Void Xbios(6,L:Varptr(Colr$)) ! Set pallette
  198.   Physbase=Xbios(2) ! Find screen
  199.   Bload Filename$,Physbase-34
  200.   Clr Temp$
  201. Return
  202. '
  203. ' ------------- SAVE ORIGINAL COLOR PALETTE -----------------------
  204. Procedure Save_pal
  205.   '
  206.   ' Requires Dim Spalette%(16,3)
  207.   '
  208.   For Z%=0 To 15
  209.     Dpoke Contrl,26
  210.     Dpoke Contrl+2,0
  211.     Dpoke Contrl+6,2
  212.     Dpoke Intin,Z%
  213.     Dpoke Intin+2,0
  214.     Vdisys
  215.     Spalette%(Z%,0)=Dpeek(Intout+2)
  216.     Spalette%(Z%,1)=Dpeek(Intout+4)
  217.     Spalette%(Z%,2)=Dpeek(Intout+6)
  218.   Next Z%
  219. Return
  220. '
  221. Procedure Restorepal
  222.   ' --------------------- RESTORES PALLET -------------------
  223.   ' Dimensions: Spalette%(16,3)
  224.   '
  225.   For Z%=0 To 15
  226.     Dpoke Contrl,14
  227.     Dpoke Contrl+2,0
  228.     Dpoke Contrl+6,4
  229.     Dpoke Intin,Z%
  230.     Dpoke Intin+2,Spalette%(Z%,0)
  231.     Dpoke Intin+4,Spalette%(Z%,1)
  232.     Dpoke Intin+6,Spalette%(Z%,2)
  233.     Vdisys
  234.   Next Z%
  235. Return
  236. '
  237.